perm filename SDIO[BNF,JRA]2 blob
sn#033005 filedate 1973-04-03 generic text, type T, neo UTF8
00100
00200 (SETQ IBASE (ADD1 7))
00300
00400
00500 (DEFPROP SDIO
00600 (NIL SDIOSET
00700 SDIOINIT
00800 IN
00900 OUT
01000 CH
01100 QCH
01200 UNCH
01300 SPWD
01400 *NIL*
01500 $PDLSIZE
01600 TOP
01700 STK0
01800 STK1
01900 STK2
02000 STK3
02100 STK4
02200 STK5
02300 OUTPDL
02400 OUTBKU
02500 START
02600 FUNFLAT
02700 DOPRINT
02800 FPRINT
02900 FSIZE
03000 SPACING
03100 SPACES
03200 OTST
03300 OUTTST
03400 <ATOM>
03500 <ID>
03600 <NUMBER>
03700 <CHAR>
03800 <UNARY_OP>
03900 FCALL
04000 >ATOM<
04100 >ID<
04200 RESERVEDWORDS
04300 >NUMBER<
04400 >CHAR<)
04500 VALUE)
04600
04700 (DEFPROP SDIOSET
04800 (LAMBDA NIL
04900 (PROG NIL
05000 (SETQ SCNVAL NIL)
05100 (*PUTSYM (QUOTE SCNVAL) (GET (QUOTE SCNVAL) (QUOTE VALUE)))
05200 (PUTSYM (TRUTH (QUOTE T)) (NILX (QUOTE *NIL*)) (STAR (QUOTE *)))))
05300 EXPR)
05400
05500 (DEFPROP SDIOINIT
05600 (LAMBDA NIL
05700 (PROG NIL
05800 (SETQ %%NIL (MAKNAM (QUOTE (N I L))))
05900 (GETSYM SUBR
06000 ATM
06100 XXTRY
06200 SCANINIT
06300 LETTER
06400 IGNORE
06500 SCAN
06600 SCANSET
06700 SCANRESET
06800 CHX
06900 SPWDX
07000 REDUCE
07100 STK
07200 PPOS
07300 PDLSET
07400 LOC
07500 FLATC
07600 NLRR
07700 LRR
07800 OUTRUL
07900 MATCH)
08000 (SCANINIT 176 12 42 42 45)
08100 (IGNORE 12)
08200 (IGNORE 175)
08300 (IGNORE 11)
08400 (IGNORE 15)
08500 (IGNORE 40)
08600 (LETTER 30)
08700 (SETQ MAXLNG 105)
08800 (SETQ FOOBAZ (LIST (QUOTE :CH) (INTERN (ASCII 0))))
08900 (DEFPROP >ATOM< ((>ATOM< . 1)) SPACING)
09000 (INITFN (FUNCTION SCANRESET))))
09100 EXPR)
09200
09300 (DEFPROP IN
09400 (LAMBDA (L) (PROG (X) (SCANSET) (START) (SETQ X (EVAL L)) (SCANRESET) (RETURN (COND (X (TOP)) (*NIL*)))))
09500 FEXPR)
09600
09700 (DEFPROP OUT
09800 (LAMBDA(%%L)
09900 (PROG NIL (SETQ &&Z (FUNFLAT (LIST (LIST (OUTTST (EVAL (CADR %%L)) (CAR %%L)))))) (OTST MAXLNG)))
10000 FEXPR)
10100
10200 (DEFPROP CH
10300 (LAMBDA (L) (LIST (QUOTE CHX) (UNCH (CADR L))))
10400 MACRO)
10500
10600 (DEFPROP QCH
10700 (LAMBDA (L) (LIST (QUOTE CHX) (UNCH (CADR L))))
10800 MACRO)
10900
11000 (DEFPROP UNCH
11100 (LAMBDA (X) (LSH (MAKNUM (CAAR (GET X (QUOTE PNAME))) (QUOTE FIXNUM)) -13))
11200 EXPR)
11300
11400 (DEFPROP SPWD
11500 (LAMBDA (L) (LIST (QUOTE SPWDX) (CONS (QUOTE QUOTE) (CDR L))))
11600 MACRO)
11700
11800 (DEFPROP *NIL*
11900 (NIL . *NIL*)
12000 VALUE)
12100
12200 (DEFPROP $PDLSIZE
12300 (NIL . 1000)
12400 VALUE)
12500
12600 (DEFPROP TOP
12700 (LAMBDA NIL (PDL 4))
12800 EXPR)
12900
13000 (DEFPROP STK0
13100 (LAMBDA NIL (STK 0))
13200 EXPR)
13300
13400 (DEFPROP STK1
13500 (LAMBDA NIL (STK 1))
13600 EXPR)
13700
13800 (DEFPROP STK2
13900 (LAMBDA NIL (STK 2))
14000 EXPR)
14100
14200 (DEFPROP STK3
14300 (LAMBDA NIL (STK 3))
14400 EXPR)
14500
14600 (DEFPROP STK4
14700 (LAMBDA NIL (STK 4))
14800 EXPR)
14900
15000 (DEFPROP STK5
15100 (LAMBDA NIL (STK 5))
15200 EXPR)
15300
15400 (DEFPROP OUTPDL
15500 (LAMBDA(N)
15600 (PROG NIL
15700 L (COND ((MINUSP N) (RETURN (QUOTE BOTTOM))))
15800 (PRINT (CONS (PDL (PLUS N N 1)) (PDL (PLUS N N))))
15900 (SETQ N (SUB1 N))
16000 (GO L)))
16100 EXPR)
16200
16300 (DEFPROP OUTBKU
16400 (LAMBDA(N)
16500 (PROG NIL
16600 L (COND ((ZEROP N) (RETURN (QUOTE BOTTOM))))
16700 (PRINT (CONS (BACKUP (PLUS N N 1)) (BACKUP (PLUS N N))))
16800 (SETQ N (SUB1 N))
16900 (GO L)))
17000 EXPR)
17100
17200 (DEFPROP START
17300 (LAMBDA NIL
17400 (PROG NIL
17500 (COND ((GET (QUOTE PDL) (QUOTE SUBR))) (T (ARRAY BACKUP T $PDLSIZE) (ARRAY PDL T $PDLSIZE)))
17600 (PDLSET (GET (QUOTE PDL) (QUOTE SUBR)) (GET (QUOTE BACKUP) (QUOTE SUBR)) (*QUO $PDLSIZE 2))))
17700 EXPR)
17800
17900 (DEFPROP FUNFLAT
18000 (LAMBDA(L)
18100 (PROG (FL FLP M S K)
18200 (SETQ S 0)
18300 (SETQ FL (SETQ FLP (CONS NIL L)))
18400 L0 (SETQ L (CDR FLP))
18500 (COND ((NULL L) (RPLACA FL S) (RETURN FL))
18600 ((EQ (SETQ M (CAR L)) (QUOTE %DOWN)) (RPLACD FLP (SETQ L (CDR L)))
18700 (COND ((ATOM (SETQ M (CAR L))) (SETQ K (FSIZE M)))
18800 ((EQ (CAR M) (QUOTE :CH))
18900 (SETQ K (ADD1 (SPACING LAST (CADR M)))))
19000 (T (RPLACA L (FUNFLAT M)) (SETQ K (CAAR L)))))
19100 ((ATOM M) (SETQ K (FSIZE M)))
19200 ((EQ (CAR M) (QUOTE :CH)) (SETQ K (ADD1 (SPACING LAST (CADR M)))))
19300 ((EQ (CAR M) (QUOTE %IN)) (SETQ K 0))
19400 (T (RPLACD FLP M) (RPLACD (LAST M) (CDR L)) (GO L0)))
19500 (SETQ S (PLUS S K))
19600 (SETQ FLP (CDR FLP))
19700 (GO L0)))
19800 EXPR)
19900
20000 (DEFPROP DOPRINT
20100 (LAMBDA(L)
20200 (COND ((ATOM L) (SPACES LAST (QUOTE >ATOM<)) (PRIN1 L))
20300 ((EQ (CAR L) (QUOTE :CH)) (SPACES LAST (CADR L)) (PRINC (CADR L)))
20400 ((EQ (CAR L) (QUOTE %IN)))
20500 (T (MAPC (FUNCTION DOPRINT) (CDR L)))))
20600 EXPR)
20700
20800 (DEFPROP FPRINT
20900 (LAMBDA(L POS)
21000 (COND ((LESSP (PLUS (CAR L) POS) MAXLNG) (DOPRINT L))
21100 (T
21200 (PROG NIL
21300 L (SETQ L (CDR L))
21400 (COND ((NULL L) (RETURN NIL))
21500 ((ATOM (CAR L)) (DOPRINT (CAR L)))
21600 ((AND (EQ (CAAR L) (QUOTE %IN)) (NUMBERP (CADAR L))) (PPOS (PLUS POS (CADAR L)))
21700 (SETQ LAST (QUOTE >CR<)))
21800 ((EQ (CAAR L) (QUOTE :CH)) (DOPRINT (CAR L)))
21900 (T (FPRINT (CAR L) (LOC))))
22000 (GO L)))))
22100 EXPR)
22200
22300 (DEFPROP FSIZE
22400 (LAMBDA (X) (PLUS (FLATSIZE X) (SPACING LAST (QUOTE >ATOM<))))
22500 EXPR)
22600
22700 (DEFPROP SPACING
22800 (LAMBDA(OLD NEW)
22900 (PROG2 (SETQ LAST NEW)
23000 (CDR (SASSOC NEW (GET OLD (QUOTE SPACING)) (FUNCTION (LAMBDA NIL (QUOTE (NIL . 0))))))))
23100 EXPR)
23200
23300 (DEFPROP SPACES
23400 (LAMBDA(OLD NEW)
23500 (PROG (N) (SETQ N (SPACING OLD NEW)) L (COND ((ZEROP N) (RETURN NIL))) (TYO 40) (SETQ N (SUB1 N)) (GO L)))
23600 EXPR)
23700
23800 (DEFPROP OTST
23900 (LAMBDA (MAXLNG) (PROG NIL (TERPRI) (SETQ LAST NIL) (FPRINT &&Z 0) (TERPRI)))
24000 EXPR)
24100
24200 (DEFPROP OUTTST
24300 (LAMBDA (X F) (PROG NIL (START) (SETQ LAST NIL) (STORE (PDL 2) X) (RETURN (F 0))))
24400 EXPR)
24500
24600 (DEFPROP <ATOM>
24700 (LAMBDA NIL (PROG2 (SCANRESET) (ATM) (SCANSET)))
24800 EXPR)
24900
25000 (DEFPROP <ID>
25100 (LAMBDA NIL (%TRY 0))
25200 EXPR)
25300
25400 (DEFPROP <NUMBER>
25500 (LAMBDA NIL (%TRY 2))
25600 EXPR)
25700
25800 (DEFPROP <CHAR>
25900 (LAMBDA NIL (NLRR (QUOTE <CHAR>) (FUNCTION (LAMBDA NIL (COND ((%TRY 3) (INTERN (ASCII (STK 0)))) (*NIL*))))))
26000 EXPR)
26100
26200 (DEFPROP <UNARY_OP>
26300 (LAMBDA NIL NIL)
26400 EXPR)
26500
26600 (DEFPROP FCALL
26700 (LAMBDA (L) (CDR L))
26800 MACRO)
26900
27000 (DEFPROP >ATOM<
27100 (LAMBDA (X) (OUTRUL X (FUNCTION (LAMBDA NIL (COND ((NULL (STK1)) (NCONS %%NIL)) ((ATOM (STK1)) (STK1)))))))
27200 EXPR)
27300
27400 (DEFPROP >ID<
27500 (LAMBDA(X)
27600 (OUTRUL X
27700 (FUNCTION
27800 (LAMBDA NIL
27900 (COND ((NUMBERP (STK1)) NIL)
28000 ((MEMBER (STK1) RESERVEDWORDS) NIL)
28100 ((NULL (STK1)) (NCONS NIL))
28200 ((ATOM (STK1)) (STK1)))))))
28300 EXPR)
28400
28500 (DEFPROP RESERVEDWORDS
28600 (NIL)
28700 VALUE)
28800
28900 (DEFPROP >NUMBER<
29000 (LAMBDA (X) (OUTRUL X (FUNCTION (LAMBDA NIL (COND ((NUMBERP (STK1)) (STK1)))))))
29100 EXPR)
29200
29300 (DEFPROP >CHAR<
29400 (LAMBDA (X) (OUTRUL X (FUNCTION (LAMBDA NIL (LIST (QUOTE :CH) (STK1))))))
29500 EXPR)
29600
29700 (SDIOSET)